;;   This file is part of scheme-GNUnet, a partial Scheme port of GNUnet.
;;   Copyright (C) 2020, 2021 Maxime Devos <maximedevos@telenet.be>
;;
;;   scheme-GNUnet is free software: you can redistribute it and/or modify it
;;   under the terms of the GNU Affero General Public License as published
;;   by the Free Software Foundation, either version 3 of the License,
;;   or (at your option) any later version.
;;
;;   scheme-GNUnet is distributed in the hope that it will be useful, but
;;   WITHOUT ANY WARRANTY; without even the implied warranty of
;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;   Affero General Public License for more details.
;;
;;   You should have received a copy of the GNU Affero General Public License
;;   along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;
;;   SPDX-License-Identifier: AGPL-3.0-or-later

;; Author: Maxime Devos
;; Source: gnu/gnunet/utils/bv-slice.scm
;; Brief: parts of bytevectors, with read/write restricted
;; (TODO: parts of vectors, uniform vectors ...)

(library (gnu gnunet utils bv-slice)
  (export slice?
	  ;; Slicing
	  slice-bv
	  slice-offset
	  slice-length
	  slice-slice
	  bv-slice/read-write
	  make-slice/read-write
	  slice-readable?
	  slice-writable?
	  slice/read-only
	  slice/write-only
	  slice/read-write
	  ;; Small operations
	  slice-u8-ref
	  slice-u16-ref
	  slice-u32-ref
	  slice-u64-ref
	  slice-u8-set!
	  slice-u16-set!
	  slice-u32-set!
	  slice-u64-set!
	  ;; Large operations
	  slice-copy!
	  slice-zero!)
  (import (rnrs arithmetic bitwise)
	  (rnrs base)
	  (rnrs bytevectors)
	  (rnrs control)
	  (rnrs records syntactic)
	  (srfi srfi-31)
	  ;; only for printing records
	  (only (rnrs io ports)
		put-char put-string)
	  (only (srfi srfi-9 gnu)
		set-record-type-printer!))
  
  ;; Slicing

  (define-record-type (<slice> %make-slice slice?)
    ;; TODO: perhaps use pointer->bytevector
    ;; and bytevector->pointer when available
    ;; to remove the use of offset and length
    (fields (immutable bv slice-bv) ;; unsafe: bounds may be ignored
	    (immutable offset slice-offset) ;; unsafe: implementation details
	    (immutable length slice-length)
	    (immutable cap-bits slice-capability-bits))
    (opaque #t)
    (sealed #t))

  ;; Not set in stone.  Override the record printer to
  ;; avoid printing large bytevectors and instead only
  ;; print the sliced part.
  (define (print-slice slice port)
    (put-string port "#<slice (")
    (put-string port
		(cond ((and (slice-readable? slice)
			    (slice-writable? slice))
		       "CAP_READ | CAP_WRITE")
		      ((slice-readable? slice)
		       "CAP_READ")
		      ((slice-writable? slice)
		       "CAP_WRITE")
		      (#t
		       "0")))
    (put-string port "):")
    (let ((bv (slice-bv slice))
	  (end (+ (slice-offset slice)
		  (slice-length slice))))
      (let loop ((i (slice-offset slice)))
	(if (< i end)
	    (let ((val (bytevector-u8-ref bv i)))
	      (put-char port #\ )
	      (put-string port (number->string val))
	      (loop (+ i 1))))))
    (put-char port #\>))
  (set-record-type-printer! <slice> print-slice)

  (define slice-slice
    (case-lambda
      "Select a part of the slice, preserving capabilities"
      ((slice)
       (assert (slice? slice))
       slice)
      ((slice offset)
       (assert (slice? slice))
       (assert (and (integer? offset)
		    (exact? offset)
		    (<= 0 offset)
		    (<= offset (slice-length slice))))
       (%make-slice (slice-bv slice)
		    (+ offset (slice-offset slice))
		    (- (slice-length slice) offset)
		    (slice-capability-bits slice)))
      ((slice offset length)
       (assert (slice? slice))
       (assert (and (integer? offset)
		    (exact? offset)
		    (<= 0 offset)))
       (assert (and (integer? length)
		    (exact? length)
		    (<= 0 length)))
       (assert (<= (+ offset length)
		   (slice-length slice)))
       (%make-slice (slice-bv slice)
		    (+ offset (slice-offset slice))
		    length
		    (slice-capability-bits slice)))))

  (define CAP_READ  #b1)
  (define CAP_WRITE #b10)
  (define CAP_ALL (bitwise-ior CAP_READ CAP_WRITE))

  (define (slice-as-well process-first-arg)
    (case-lambda
      "Do @var{process-first-arg}, and then perhaps slice"
      ((obj)
       (process-first-arg obj))
      ((obj offset)
       (slice-slice (process-first-arg obj) offset))
      ((obj offset length)
       (slice-slice (process-first-arg obj) offset length))))

  (define bv-slice/read-write
    (slice-as-well
     (lambda (bv)
      "Construct a read-write bytevector slice.  Mutations will change
the bytevector in place."
      (assert (bytevector? bv))
      (%make-slice bv 0 (bytevector-length bv)
		   (bitwise-ior CAP_READ CAP_WRITE)))))

  (define (make-slice/read-write length)
    "Make a fresh, zero-initialised, read-write slice"
    (bv-slice/read-write (make-bytevector length 0)))

  (define (make-slice-cap-p required-cap-bits)
    (assert (= (bitwise-and required-cap-bits CAP_ALL)
	       required-cap-bits))
    (lambda (slice)
      "Does @var{slice} have the capabilities @var{required-cap-bits}?"
      (= (bitwise-and (slice-capability-bits slice) required-cap-bits)
	 required-cap-bits)))

  (define slice-readable? (make-slice-cap-p CAP_READ))
  (define slice-writable? (make-slice-cap-p CAP_WRITE))

  (define (make-select-capabilities desired-cap-bits)
    (let ((ok? (make-slice-cap-p desired-cap-bits)))
      (slice-as-well
       (lambda (slice)
	 (assert (ok? slice))
	 (%make-slice (slice-bv slice)
		      (slice-offset slice)
		      (slice-length slice)
		      desired-cap-bits)))))
  (define slice/read-only
    (make-select-capabilities CAP_READ))
  (define slice/write-only
    (make-select-capabilities CAP_WRITE))
  (define slice/read-write
    (make-select-capabilities (bitwise-ior CAP_READ CAP_WRITE)))

  
  ;; ‘Small’ operations

  (define (wrap-rnrs-ref rnrs-ref ok? size)
    (lambda (slice index . rest)
      (assert (and (exact? index)
		   (integer? index)
		   (<= 0 index)
		   (<= (+ index size) (slice-length slice))))
      (assert (ok? slice))
      (apply rnrs-ref (slice-bv slice)
	     (+ (slice-offset slice) index)
	     rest)))

  (define slice-u8-ref
    (wrap-rnrs-ref bytevector-u8-ref slice-readable? 1))
  (define slice-u16-ref
    (wrap-rnrs-ref bytevector-u16-ref slice-readable? 2))
  (define slice-u32-ref
    (wrap-rnrs-ref bytevector-u32-ref slice-readable? 4))
  (define slice-u64-ref
    (wrap-rnrs-ref bytevector-u64-ref slice-readable? 8))

  (define slice-u8-set!
    (wrap-rnrs-ref bytevector-u8-set! slice-writable? 1))
  (define slice-u16-set!
    (wrap-rnrs-ref bytevector-u16-set! slice-writable? 2))
  (define slice-u32-set!
    (wrap-rnrs-ref bytevector-u32-set! slice-writable? 4))
  (define slice-u64-set!
    (wrap-rnrs-ref bytevector-u64-set! slice-writable? 8))

  
  ;; ‘Large’ operations.

  (define (slice-zero! slice)
    "Zero out the writable slice @var{slice}."
    (assert (slice-writable? slice))
    ;; TODO optimise this and/or optimise guile's compiler
    ;; w.r.t. bytevectors, structs and type inference.
    (let loop ((i 0))
      (when (< i (slice-length slice))
	(slice-u8-set! slice i 0)
	(loop (+ i 1))))
    (values))

  (define (slice-copy! from to)
    "Copy the contents of the readable slice @var{from} to
the writable slice @var{slice}.  The slices may overlap."
    (assert (slice-readable? from))
    (assert (slice-writable? to))
    (assert (= (slice-length from) (slice-length to)))
    (bytevector-copy! (slice-bv from) (slice-offset from)
		      (slice-bv to) (slice-offset to)
		      (slice-length from))
    (values)))
